home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / rdms.scm < prev    next >
Text File  |  1999-04-19  |  21KB  |  617 lines
  1. ;;; "rdms.scm" rewrite 6 - the saga continues
  2. ; Copyright 1994, 1995, 1997 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define rdms:catalog-name '*catalog-data*)
  21. (define rdms:domains-name '*domains-data*)
  22. (define rdms:columns-name '*columns*)
  23.  
  24. (define catalog:init-cols
  25.   '((1 #t table-name        #f atom)
  26.     (2 #f column-limit        #f uint)
  27.     (3 #f coltab-name        #f atom)
  28.     (4 #f bastab-id        #f base-id)
  29.     (5 #f user-integrity-rule    #f expression)
  30.     (6 #f view-procedure    #f expression)))
  31.  
  32. (define catalog:column-limit-pos 2)
  33. (define catalog:coltab-name-pos 3)
  34. (define catalog:bastab-id-pos 4)
  35. (define catalog:integrity-rule-pos 5)
  36. (define catalog:view-proc-pos 6)
  37.  
  38. (define columns:init-cols
  39.   '((1 #t column-number        #f uint)
  40.     (2 #f primary-key?        #f boolean)
  41.     (3 #f column-name        #f symbol)
  42.     (4 #f column-integrity-rule    #f expression)
  43.     (5 #f domain-name        #f domain)))
  44.  
  45. (define columns:primary?-pos 2)
  46. (define columns:name-pos 3)
  47. (define columns:integrity-rule-pos 4)
  48. (define columns:domain-name-pos 5)
  49.  
  50. (define domains:init-cols
  51.   '((1 #t domain-name        #f atom)
  52.     (2 #f foreign-table        #f atom)
  53.     (3 #f domain-integrity-rule    #f expression)
  54.     (4 #f type-id        #f type)
  55.     (5 #f type-param        #f expression)))
  56.  
  57. (define domains:foreign-pos 2)
  58. (define domains:integrity-rule-pos 3)
  59. (define domains:type-id-pos 4)
  60. (define domains:type-param-pos 5)
  61.  
  62. (define domains:init-data
  63.   `((atom #f
  64.           (lambda (x) (or (not x) (symbol? x) (number? x)))
  65.           atom
  66.           #f)
  67.     (type #f
  68.       #f                ;type checked when openning
  69.       symbol
  70.       #f)
  71.     (base-id #f
  72.          (lambda (x) (or (symbol? x) (number? x)))
  73.          base-id
  74.          #f)
  75.     (uint #f
  76.           (lambda (x)
  77.             (and (number? x)
  78.                  (integer? x)
  79.                  (not (negative? x))))
  80.           integer
  81.           #f)
  82.     (number #f number? number #f)
  83.     (expression #f #f expression #f)
  84.     (boolean #f boolean? boolean #f)
  85.     (symbol #f symbol? symbol #f)
  86.     (string #f string? string #f)
  87.     (domain ,rdms:domains-name #f atom #f)))
  88.  
  89. (define rdms:warn slib:warn)
  90. (define rdms:error slib:error)
  91.  
  92. (define (make-relational-system base)
  93.   (define basic
  94.     (lambda (name)
  95.       (let ((meth (base name)))
  96.     (cond ((not meth) (rdms:error 'make-relational-system
  97.                       "essential method missing for:" name)))
  98.     meth)))
  99.  
  100.   (define (desc-row-type row)
  101.     (let ((domain (assq (car (cddddr row)) domains:init-data)))
  102.       (and domain (cadddr domain))))
  103.  
  104.   (let ((make-base (base 'make-base))
  105.     (open-base (basic 'open-base))
  106.     (write-base (base 'write-base))
  107.     (sync-base (base 'sync-base))
  108.     (close-base (basic 'close-base))
  109.     (base:supported-type? (basic 'supported-type?))
  110.     (base:supported-key-type? (basic 'supported-key-type?))
  111.     (base:make-table (base 'make-table))
  112.     (base:open-table (basic 'open-table))
  113.     (base:kill-table (base 'kill-table))
  114.     (present? (basic 'present?))
  115.     (base:ordered-for-each-key (basic 'ordered-for-each-key))
  116.     (base:for-each-primary-key (basic 'for-each-key))
  117.     (base:map-primary-key (basic 'map-key))
  118.     (base:catalog-id (basic 'catalog-id))
  119.     (cat:keyify-1 ((basic 'make-keyifier-1)
  120.                (desc-row-type (assv 1 catalog:init-cols))))
  121.     (itypes
  122.      (lambda (rows)
  123.        (map (lambda (row)
  124.           (let ((domrow (assq (car (cddddr row)) domains:init-data)))
  125.             (cond (domrow (cadddr domrow))
  126.               (else (rdms:error 'itypes "type not found for:"
  127.                         (car (cddddr row)))))))
  128.         rows))))
  129.  
  130.     (define (init-tab lldb id descriptor rows)
  131.       (let ((han (base:open-table lldb id 1 (itypes descriptor)))
  132.         (keyify-1
  133.          ((base 'make-keyifier-1) (desc-row-type (assv 1 descriptor))))
  134.         (putter ((basic 'make-putter) 1 (itypes descriptor))))
  135.     (for-each (lambda (row) (putter han (keyify-1 (car row)) (cdr row)))
  136.           rows)))
  137.  
  138.     (define cat:get-row
  139.       (let ((cat:getter ((basic 'make-getter) 1 (itypes catalog:init-cols))))
  140.     (lambda (bastab key)
  141.       (cat:getter bastab (cat:keyify-1 key)))))
  142.  
  143.     (define dom:get-row
  144.       (let ((dom:getter ((basic 'make-getter) 1 (itypes domains:init-cols)))
  145.         (dom:keyify-1 ((basic 'make-keyifier-1)
  146.                (desc-row-type (assv 1 domains:init-cols)))))
  147.     (lambda (bastab key)
  148.       (dom:getter bastab (dom:keyify-1 key)))))
  149.  
  150.     (define des:get-row
  151.       (let ((des:getter ((basic 'make-getter) 1 (itypes columns:init-cols)))
  152.         (des:keyify-1 ((basic 'make-keyifier-1)
  153.                (desc-row-type (assv 1 columns:init-cols)))))
  154.     (lambda (bastab key)
  155.       (des:getter bastab (des:keyify-1 key)))))
  156.  
  157.     (define (create-database filename)
  158.       (cond ((and filename (file-exists? filename))
  159.          (rdms:warn 'create-database "file exists:" filename)))
  160.       (let* ((lldb (make-base filename 1 (itypes catalog:init-cols)))
  161.          (cattab (and lldb (base:open-table lldb base:catalog-id 1
  162.                         (itypes catalog:init-cols)))))
  163.     (cond
  164.      ((not lldb) (rdms:error 'make-base "failed.") #f)
  165.      ((not cattab) (rdms:error 'make-base "catalog missing.")
  166.                (close-base lldb)
  167.                #f)
  168.      (else
  169.       (let ((desdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
  170.         (domdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
  171.         (catdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
  172.         (domtab-id (base:make-table lldb 1 (itypes domains:init-cols)))
  173.         )
  174.         (cond
  175.          ((not (and catdes-id domdes-id domtab-id desdes-id))
  176.           (rdms:error 'create-database "make-table failed.")
  177.           (close-base lldb)
  178.           #f)
  179.          (else
  180.           (init-tab lldb desdes-id columns:init-cols columns:init-cols)
  181.           (init-tab lldb domdes-id columns:init-cols domains:init-cols)
  182.           (init-tab lldb catdes-id columns:init-cols catalog:init-cols)
  183.           (init-tab lldb domtab-id domains:init-cols domains:init-data)
  184.           (init-tab
  185.            lldb base:catalog-id catalog:init-cols
  186.            `((*catalog-desc* 5 ,rdms:columns-name ,catdes-id #f #f)
  187.          (*domains-desc* 5 ,rdms:columns-name ,domdes-id #f #f)
  188.          (,rdms:catalog-name 6 *catalog-desc* ,base:catalog-id #f #f)
  189.          (,rdms:domains-name 5 *domains-desc* ,domtab-id #f #f)
  190.          (,rdms:columns-name 5 ,rdms:columns-name ,desdes-id #f #f)))
  191.           (init-database
  192.            filename #t lldb cattab
  193.            (base:open-table lldb domtab-id 1 (itypes domains:init-cols))
  194.            #f))))))))
  195.  
  196.     (define (base:catalog->domains lldb base:catalog)
  197.       (let ((cat:row (cat:get-row base:catalog rdms:domains-name)))
  198.     (and cat:row
  199.          (base:open-table lldb
  200.                   (list-ref cat:row (+ -2 catalog:bastab-id-pos))
  201.                   1 (itypes domains:init-cols)))))
  202.  
  203.     (define (open-database filename mutable)
  204.       (let* ((lldb (open-base filename mutable))
  205.          (base:catalog
  206.           (and lldb (base:open-table lldb base:catalog-id
  207.                      1 (itypes catalog:init-cols))))
  208.          (base:domains
  209.           (and base:catalog (base:catalog->domains lldb base:catalog))))
  210.     (cond
  211.      ((not lldb) #f)
  212.      ((not base:domains) (close-base lldb) #f)
  213.      (else (init-database
  214.         filename mutable lldb base:catalog base:domains #f)))))
  215.  
  216.     (define (init-database rdms:filename mutable lldb
  217.                base:catalog base:domains rdms:catalog)
  218.  
  219.       (define (write-database filename)
  220.     (let ((ans (write-base lldb filename)))
  221.       (and ans (set! rdms:filename filename))
  222.       ans))
  223.  
  224.       (define (close-database)
  225.     (close-base lldb)
  226.     (set! rdms:filename #f)
  227.     (set! base:catalog #f)
  228.     (set! base:domains #f)
  229.     (set! rdms:catalog #f))
  230.  
  231.       (define row-ref (lambda (row pos) (list-ref row (+ -2 pos))))
  232.       (define row-eval (lambda (row pos)
  233.              (let ((ans (list-ref row (+ -2 pos))))
  234.                (and ans (slib:eval ans)))))
  235.  
  236.       (define (open-table table-name writable)
  237.     (define cat:row (cat:get-row base:catalog table-name))
  238.     (cond ((not cat:row)
  239.            (rdms:error "can't open-table:" table-name))
  240.           ((and writable (not mutable))
  241.            (rdms:error "can't open-table for writing:" table-name)))
  242.     (let ((column-limit (row-ref cat:row catalog:column-limit-pos))
  243.           (desc-table
  244.            (base:open-table
  245.         lldb
  246.         (row-ref (cat:get-row
  247.               base:catalog
  248.               (row-ref cat:row catalog:coltab-name-pos))
  249.              catalog:bastab-id-pos)
  250.         1 (itypes columns:init-cols)))
  251.           (base-table #f)
  252.           (base:get #f)
  253.           (primary-limit 1)
  254.           (column-name-alist '())
  255.           (column-foreign-list '())
  256.           (column-foreign-check-list '())
  257.           (column-domain-list '())
  258.           (column-type-list '())
  259.           (export-alist '())
  260.           (cirs '())
  261.           (dirs '())
  262.           (list->key #f)
  263.           (key->list #f))
  264.  
  265.       (if (not desc-table)
  266.           (rdms:error "descriptor table doesn't exist for:" table-name))
  267.       (do ((ci column-limit (+ -1 ci)))
  268.           ((zero? ci))
  269.         (let* ((des:row (des:get-row desc-table ci))
  270.            (column-name (row-ref des:row columns:name-pos))
  271.            (column-domain (row-ref des:row columns:domain-name-pos)))
  272.           (set! cirs
  273.             (cons (row-eval des:row columns:integrity-rule-pos) cirs))
  274.           (set! column-name-alist
  275.             (cons (cons column-name ci) column-name-alist))
  276.           (cond
  277.            (column-domain
  278.         (let ((dom:row (dom:get-row base:domains column-domain)))
  279.           (set! dirs
  280.             (cons (row-eval dom:row domains:integrity-rule-pos)
  281.                   dirs))
  282.           (set! column-type-list
  283.             (cons (row-ref dom:row domains:type-id-pos)
  284.                   column-type-list))
  285.           (set! column-domain-list
  286.             (cons column-domain column-domain-list))
  287.           (set! column-foreign-list
  288.             (cons (let ((foreign-name
  289.                      (row-ref dom:row domains:foreign-pos)))
  290.                 (and (not (eq? foreign-name table-name))
  291.                      foreign-name))
  292.                   column-foreign-list))
  293.           (set! column-foreign-check-list
  294.             (cons 
  295.              (let ((foreign-name (car column-foreign-list)))
  296.                (and foreign-name
  297.                 (let* ((tab (open-table foreign-name #f))
  298.                        (p? (and tab (tab 'get 1))))
  299.                   (cond
  300.                    ((not tab)
  301.                     (rdms:error "foreign key table missing for:"
  302.                         foreign-name))
  303.                    ((not (= (tab 'primary-limit) 1))
  304.                     (rdms:error "foreign key table wrong type:"
  305.                         foreign-name))
  306.                    (else p?)))))
  307.              column-foreign-check-list))))
  308.            (else
  309.         (rdms:error "missing domain for column:" ci column-name)))
  310.           (cond
  311.            ((row-ref des:row columns:primary?-pos)
  312.         (set! primary-limit (max primary-limit ci))
  313.         (cond
  314.          ((base:supported-key-type? (car column-type-list)))
  315.          (else (rdms:error "key type not supported by base tables:"
  316.                    (car column-type-list)))))
  317.            ((base:supported-type? (car column-type-list)))
  318.            (else (rdms:error "type not supported by base tables:"
  319.                  (car column-type-list))))))
  320.       (set! base-table
  321.         (base:open-table lldb (row-ref cat:row catalog:bastab-id-pos)
  322.                  primary-limit column-type-list))
  323.       (set! base:get ((basic 'make-getter) primary-limit column-type-list))
  324.       (set! list->key
  325.         ((basic 'make-list-keyifier) primary-limit column-type-list))
  326.       (set! key->list
  327.         ((basic 'make-key->list) primary-limit column-type-list))
  328.       (letrec ((export-method
  329.             (lambda (name proc)
  330.               (set! export-alist
  331.                 (cons (cons name proc) export-alist))))
  332.            (ckey:retrieve    ;ckey gets whole row (assumes exists)
  333.             (if (= primary-limit column-limit) key->list
  334.             (lambda (ckey) (append (key->list ckey)
  335.                            (base:get base-table ckey)))))
  336.            (accumulate-over-table
  337.             (lambda (operation)
  338.               (lambda mkeys (base:map-primary-key
  339.                      base-table operation (norm-mkeys mkeys)))))
  340.            (norm-mkeys
  341.             (lambda (mkeys)
  342.               (define mlim (length mkeys))
  343.               (cond ((> mlim primary-limit)
  344.                  (rdms:error "too many keys:" mkeys))
  345.                 ((= mlim primary-limit) mkeys)
  346.                 (else
  347.                  (append mkeys
  348.                      (make-list (- primary-limit mlim) #f)))))))
  349.         (export-method
  350.          'row:retrieve
  351.          (if (= primary-limit column-limit)
  352.          (lambda keys
  353.            (let ((ckey (list->key keys)))
  354.              (and (present? base-table ckey) keys)))
  355.          (lambda keys
  356.            (let ((vals (base:get base-table (list->key keys))))
  357.              (and vals (append keys vals))))))
  358.         (export-method 'row:retrieve*
  359.                (accumulate-over-table
  360.                 (if (= primary-limit column-limit) key->list
  361.                 ckey:retrieve)))
  362.         (export-method
  363.          'for-each-row
  364.          (let ((r (if (= primary-limit column-limit) key->list
  365.               ckey:retrieve)))
  366.            (lambda (proc . mkeys)
  367.          (base:ordered-for-each-key
  368.           base-table (lambda (ckey) (proc (r ckey)))
  369.           (norm-mkeys mkeys)))))
  370.         (cond
  371.          ((and mutable writable)
  372.           (letrec
  373.           ((combine-primary-keys
  374.             (cond
  375.              ((and (= primary-limit column-limit)
  376.                (> primary-limit 0))
  377.               list->key)
  378.              ((eq? list->key car) list->key)
  379.              (else
  380.               (case primary-limit
  381.             ((1) (let ((keyify-1 ((base 'make-keyifier-1)
  382.                           (car column-type-list))))
  383.                    (lambda (row) (keyify-1 (car row)))))
  384.             ((2) (lambda (row)
  385.                    (list->key (list (car row) (cadr row)))))
  386.             ((3) (lambda (row)
  387.                    (list->key (list (car row) (cadr row)
  388.                         (caddr row)))))
  389.             ((4) (lambda (row)
  390.                    (list->key
  391.                 (list (car row) (cadr row)
  392.                       (caddr row) (cadddr row)))))
  393.             (else (rdms:error 'combine-primary-keys
  394.                       "bad number of primary keys"
  395.                       primary-limit))))))
  396.            (uir (row-eval cat:row catalog:integrity-rule-pos))
  397.            (check-rules
  398.             (lambda (row)
  399.               (if (= column-limit (length row)) #t
  400.               (rdms:error "bad row length:" row))
  401.               (for-each
  402.                (lambda (cir dir value column-name column-domain
  403.                     foreign)
  404.              (cond
  405.               ((and dir (not (dir value)))
  406.                (rdms:error "violated domain integrity rule:"
  407.                        table-name column-name
  408.                        column-domain value))
  409.               ((and cir (not (cir value)))
  410.                (rdms:error "violated column integrity rule:"
  411.                        table-name column-name value))
  412.               ((and foreign (not (foreign value)))
  413.                (rdms:error "foreign key missing:"
  414.                        table-name column-name value))))
  415.                cirs dirs row column-name-alist column-domain-list
  416.                column-foreign-check-list)
  417.               (cond ((and uir (not (uir row)))
  418.                  (rdms:error "violated user integrity rule:"
  419.                      row)))))
  420.            (putter
  421.             ((basic 'make-putter) primary-limit column-type-list))
  422.            (row:insert
  423.             (lambda (row)
  424.               (check-rules row)
  425.               (let ((ckey (combine-primary-keys row)))
  426.             (if (present? base-table ckey)
  427.                 (rdms:error 'row:insert "row present:" row))
  428.             (putter base-table ckey
  429.                 (list-tail row primary-limit)))))
  430.            (row:update
  431.             (lambda (row)
  432.               (check-rules row)
  433.               (putter base-table (combine-primary-keys row)
  434.                   (list-tail row primary-limit)))))
  435.  
  436.         (export-method 'row:insert row:insert)
  437.         (export-method 'row:insert*
  438.                    (lambda (rows) (for-each row:insert rows)))
  439.         (export-method 'row:update row:update)
  440.         (export-method 'row:update*
  441.                    (lambda (rows) (for-each row:update rows))))
  442.  
  443.           (letrec ((base:delete (basic 'delete))
  444.                (base:delete* (basic 'delete*))
  445.                (ckey:remove (lambda (ckey)
  446.                       (let ((r (ckey:retrieve ckey)))
  447.                     (and r (base:delete base-table ckey))
  448.                     r))))
  449.         (export-method 'row:remove
  450.                    (lambda keys
  451.                  (let ((ckey (list->key keys)))
  452.                    (and (present? base-table ckey)
  453.                     (ckey:remove ckey)))))
  454.         (export-method 'row:delete
  455.                    (lambda keys
  456.                  (base:delete base-table (list->key keys))))
  457.         (export-method 'row:remove*
  458.                    (accumulate-over-table ckey:remove))
  459.         (export-method 'row:delete*
  460.                    (lambda mkeys
  461.                  (base:delete* base-table (norm-mkeys mkeys))))
  462.         (export-method 'close-table
  463.                    (lambda () (set! base-table #f)
  464.                        (set! desc-table #f)
  465.                        (set! export-alist #f))))))
  466.  
  467.         (export-method 'column-names (map car column-name-alist))
  468.         (export-method 'column-foreigns column-foreign-list)
  469.         (export-method 'column-domains column-domain-list)
  470.         (export-method 'column-types column-type-list)
  471.         (export-method 'primary-limit primary-limit)
  472.  
  473.         (let ((translate-column
  474.            (lambda (column)
  475.              ;;(print 'translate-column column column-name-alist)
  476.              (let ((colp (assq column column-name-alist)))
  477.                (cond (colp (cdr colp))
  478.                  ((and (number? column)
  479.                    (integer? column)
  480.                    (<= 1 column column-limit))
  481.                   column)
  482.                  (else (rdms:error "column not in table:"
  483.                            column table-name)))))))
  484.           (lambda args
  485.         (cond
  486.          ((null? args)
  487.           #f)
  488.          ((null? (cdr args))
  489.           (let ((pp (assq (car args) export-alist)))
  490.             (and pp (cdr pp))))
  491.          ((not (null? (cddr args)))
  492.           (rdms:error "too many arguments to methods:" args))
  493.          (else
  494.           (let ((ci (translate-column (cadr args))))
  495.             (cond
  496.              ((<= ci primary-limit) ;primary-key?
  497.               (case (car args)
  498.             ((get) (lambda gkeys
  499.                  (and (present? base-table (list->key gkeys))
  500.                       (list-ref gkeys (+ -1 ci)))))
  501.             ((get*) (let ((key-extractor
  502.                        ((base 'make-key-extractor)
  503.                     primary-limit column-type-list ci)))
  504.                   (lambda mkeys
  505.                     (base:map-primary-key
  506.                      base-table
  507.                      (lambda (ckey) (key-extractor ckey))
  508.                      (norm-mkeys mkeys)))))
  509.             (else #f)))
  510.              (else
  511.               (let ((index (- ci (+ 1 primary-limit))))
  512.             (case (car args)
  513.               ((get) (lambda keys
  514.                    (let ((row (base:get base-table
  515.                             (list->key keys))))
  516.                      (and row (list-ref row index)))))
  517.               ((get*) (lambda mkeys
  518.                     (base:map-primary-key
  519.                      base-table
  520.                      (lambda (ckey)
  521.                        (list-ref (base:get base-table ckey)
  522.                          index))
  523.                      (norm-mkeys mkeys))))
  524.               (else #f)))))))))))))
  525.  
  526.       (define create-table
  527.     (and
  528.      mutable
  529.      (lambda (table-name . desc)
  530.        (if (not rdms:catalog)
  531.            (set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
  532.        (cond
  533.         ((table-exists? table-name)
  534.          (rdms:error "table already exists:" table-name) #f)
  535.         ((null? desc)
  536.          (let ((colt-id
  537.             (base:make-table lldb 1 (itypes columns:init-cols))))
  538.            ((rdms:catalog 'row:insert)
  539.         (list table-name
  540.               (length columns:init-cols)
  541.               ((rdms:catalog 'get 'coltab-name)
  542.                rdms:columns-name)
  543.               colt-id
  544.               #f
  545.               #f)))
  546.          (open-table table-name #t))
  547.         ((null? (cdr desc))
  548.          (set! desc (car desc))
  549.          (let ((colt-id ((rdms:catalog 'get 'bastab-id) desc)))
  550.            (cond
  551.         (colt-id
  552.          (let ((coltable (open-table desc #f))
  553.                (types '())
  554.                (prilimit 0)
  555.                (colimit 0)
  556.                (colerr #f))
  557.            (for-each (lambda (n p d)
  558.                    (if (number? n) (set! colimit (max colimit n))
  559.                    (set! colerr #t))
  560.                    (if p (set! prilimit (+ 1 prilimit)) #f)
  561.                    (set! types
  562.                      (cons (dom:get-row base:domains d)
  563.                        types)))
  564.                  ((coltable 'get* 'column-number))
  565.                  ((coltable 'get* 'primary-key?))
  566.                  ((coltable 'get* 'domain-name)))
  567.            (cond (colerr (rdms:error "some column lacks a number.") #f)
  568.              ((or (< prilimit 1)
  569.                   (and (> prilimit 4)
  570.                    (not (= prilimit colimit))))
  571.               (rdms:error "unreasonable number of primary keys:"
  572.                       prilimit))
  573.              (else
  574.               ((rdms:catalog 'row:insert)
  575.                (list table-name colimit desc
  576.                  (base:make-table lldb prilimit types) #f #f))
  577.               (open-table table-name #t)))))
  578.         (else
  579.          (rdms:error "table descriptor not found for:" desc) #f))))
  580.         (else (rdms:error 'create-table "too many args:"
  581.                   (cons table-name desc))
  582.           #f)))))
  583.  
  584.       (define (table-exists? table-name)
  585.     (present? base:catalog (cat:keyify-1 table-name)))
  586.  
  587.       (define delete-table
  588.     (and mutable
  589.          (lambda (table-name)
  590.            (if (not rdms:catalog)
  591.            (set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
  592.            (let ((table (open-table table-name #t))
  593.              (row ((rdms:catalog 'row:remove) table-name)))
  594.          (and row (base:kill-table
  595.                lldb
  596.                (list-ref row (+ -1 catalog:bastab-id-pos))
  597.                (table 'primary-limit)
  598.                (table 'column-type-list))
  599.               row)))))
  600.  
  601.       (lambda (operation-name)
  602.     (case operation-name
  603.       ((close-database) close-database)
  604.       ((write-database) write-database)
  605.       ((open-table) open-table)
  606.       ((delete-table) delete-table)
  607.       ((create-table) create-table)
  608.       ((table-exists?) table-exists?)
  609.       (else #f)))
  610.       )
  611.     (lambda (operation-name)
  612.       (case operation-name
  613.     ((create-database) create-database)
  614.     ((open-database) open-database)
  615.     (else #f)))
  616.     ))
  617.